home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / lib / hbc / Printf.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  3.9 KB  |  152 lines  |  [TEXT/YHS2]
  1. -- A C printf like formatter.
  2. -- Conversion specs:
  3. --    -    left adjust
  4. --    num    field width
  5. --    .    separates width from precision
  6. -- Formatting characters:
  7. --     c    Char, Int, Integer
  8. --    d    Char, Int, Integer
  9. --    o    Char, Int, Integer
  10. --    x    Char, Int, Integer
  11. --    u    Char, Int, Integer
  12. --    f    Float, Double
  13. --    g    Float, Double
  14. --    e    Float, Double
  15. --    s    String
  16. --
  17. module Printf(UPrintf(..), printf) where
  18.  
  19. -- import LMLfmtf
  20. import PrintfPrims
  21.  
  22. data UPrintf = UChar Char |
  23.            UString String |
  24.                UInt Int |
  25.            UInteger Integer |
  26.                UFloat Float |
  27.            UDouble Double
  28.  
  29. printf :: String -> [UPrintf] -> String
  30. printf ""       []       = ""
  31. printf ""       (_:_)    = fmterr
  32. printf ('%':_)  []       = argerr
  33. printf ('%':cs) us@(_:_) = fmt cs us
  34. printf (c:cs)   us       = c:printf cs us
  35.  
  36. fmt :: String -> [UPrintf] -> String
  37. fmt cs us =
  38.     let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
  39.         adjust (pre, str) = 
  40.         let lstr = length str
  41.             lpre = length pre
  42.             fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
  43.         in  if ladj then pre ++ str ++ fill else pre ++ fill ++ str
  44.         in
  45.     case cs' of
  46.     []     -> fmterr
  47.     c:cs'' ->
  48.         case us' of
  49.         []     -> argerr
  50.         u:us'' ->
  51.         (case c of
  52.         'c' -> adjust ("", [chr (toint u)])
  53.         'd' -> adjust (fmti u)
  54.         'x' -> adjust ("", fmtu 16 u)
  55.         'o' -> adjust ("", fmtu 8  u)
  56.         'u' -> adjust ("", fmtu 10 u)
  57.         '%' -> "%"
  58.         'e' -> adjust (fmte prec (todbl u))
  59.         'f' -> adjust (fmtf prec (todbl u))
  60.         'g' -> adjust (fmtg prec (todbl u))
  61.         's' -> adjust ("", tostr u)
  62.         c   -> perror ("bad formatting char " ++ [c])
  63.         ) ++ printf cs'' us''
  64. unimpl = perror "unimplemented"
  65.  
  66. fmti (UInt i)     = if i < 0 then
  67.             if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
  68.             else
  69.             ("", itos i)
  70. fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
  71. fmti (UChar c)    = fmti (UInt (ord c))
  72. fmti u          = baderr
  73.  
  74. fmtu b (UInt i)     = if i < 0 then
  75.               if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
  76.               else
  77.               itosb b (toInteger i)
  78. fmtu b (UInteger i) = itosb b i
  79. fmtu b (UChar c)    = itosb b (toInteger (ord c))
  80. fmtu b u            = baderr
  81.  
  82. maxi :: Integer
  83. maxi = (toInteger maxInt + 1) * 2
  84.  
  85. toint (UInt i)     = i
  86. toint (UInteger i) = toInt i
  87. toint (UChar c)    = ord c
  88. toint u           = baderr
  89.  
  90. tostr (UString s) = s
  91. tostr u          = baderr
  92.  
  93. todbl (UDouble d) = d
  94. todbl (UFloat f)  = fromRational (toRational f)
  95. todbl u           = baderr
  96.  
  97. itos n = 
  98.     if n < 10 then 
  99.         [chr (ord '0' + toInt n)]
  100.     else
  101.         let (q, r) = quotRem n 10 in
  102.         itos q ++ [chr (ord '0' + toInt r)]
  103.  
  104. chars = array (0,15) (zipWith (:=) [0..] "0123456789abcdef")
  105. itosb :: Integer -> Integer -> String
  106. itosb b n = 
  107.     if n < b then 
  108.         [chars!n]
  109.     else
  110.         let (q, r) = quotRem n b in
  111.         itosb b q ++ [chars!r]
  112.  
  113. stoi :: Int -> String -> (Int, String)
  114. stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs
  115. stoi a cs                 = (a, cs)
  116.  
  117. getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
  118. getSpecs l z ('-':cs) us = getSpecs True z cs us
  119. getSpecs l z ('0':cs) us = getSpecs l True cs us
  120. getSpecs l z ('*':cs) us = unimpl
  121. getSpecs l z cs@(c:_) us | isDigit c =
  122.     let (n, cs') = stoi 0 cs
  123.         (p, cs'') = case cs' of
  124.             '.':r -> stoi 0 r
  125.             _     -> (-1, cs')
  126.     in  (n, p, l, z, cs'', us)
  127. getSpecs l z cs       us = (0, -1, l, z, cs, us)
  128.  
  129.  
  130. fmte p d =
  131.   case (primFmte p d) of
  132.     '-':cs -> ("-",cs)
  133.     cs     -> ("",cs)
  134. fmtf p d =
  135.   case (primFmtf p d) of
  136.     '-':cs -> ("-",cs)
  137.     cs     -> ("",cs)
  138. fmtg p d =
  139.   case (primFmtg p d) of
  140.     '-':cs -> ("-",cs)
  141.     cs     -> ("",cs)
  142.  
  143. perror s = error ("Printf.printf: "++s)
  144. fmterr = perror "formatting string ended prematurely"
  145. argerr = perror "argument list ended prematurely"
  146. baderr = perror "bad argument"
  147.  
  148. -- This is needed because standard Haskell does not have toInt
  149.  
  150. toInt :: Integral a => a -> Int
  151. toInt x = fromIntegral x
  152.